home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlobj.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  14.6 KB  |  639 lines
  1. /* xlobj - xlisp object functions */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7.  
  8. /* external variables */
  9. extern LVAL xlenv,xlfenv,xlvalue;
  10. extern LVAL s_stdout,s_lambda;
  11.  
  12. /* local variables */
  13. static LVAL s_self=0,k_new=0,k_isnew=0;
  14. #ifdef OBJPRNT
  15. static LVAL k_prin1,k_fix2;
  16. #endif
  17. static LVAL class=0,object=0;
  18.  
  19. /* instance variable numbers for the class 'Class' */
  20. #define MESSAGES        0        /* list of messages */
  21. #define IVARS            1        /* list of instance variable names */
  22. #define CVARS            2        /* list of class variable names */
  23. #define CVALS            3        /* list of class variable values */
  24. #define SUPERCLASS        4        /* pointer to the superclass */
  25. #define IVARCNT            5        /* number of class instance variables */
  26. #define IVARTOTAL        6        /* total number of instance variables */
  27. #ifdef OBJPRNT
  28. #define PNAME            7        /* print name TAA Mod */
  29. #endif
  30. /* number of instance variables for the class 'Class' */
  31. #ifdef OBJPRNT
  32. #define CLASSSIZE        8        /* TAA mod */
  33. #else
  34. #define CLASSSIZE        7
  35. #endif
  36.  
  37. /* forward declarations */
  38. #ifdef ANSI
  39. LVAL entermsg(LVAL cls, LVAL msg);
  40. LVAL sendmsg(LVAL obj, LVAL cls, LVAL sym);
  41. LVAL evmethod(LVAL obj, LVAL msgcls, LVAL method);
  42. int  getivcnt(LVAL cls, int ivar);
  43. int  listlength(LVAL list);
  44. #else
  45. FORWARD LVAL entermsg();
  46. FORWARD LVAL sendmsg();
  47. FORWARD LVAL evmethod();
  48. #endif
  49.  
  50. #ifdef OBJPRNT
  51. /* routine to print an object for PRINx */
  52. extern char buf[];
  53. #ifdef ANSI
  54. static VOID xputobj(LVAL fptr, LVAL val)
  55. #else
  56. LOCAL VOID xputobj(fptr,val)
  57.   LVAL fptr; LVAL val;
  58. #endif
  59. {
  60.     LVAL temp;
  61.     if ((temp = getclass(val)) == class) { /* this is a class */
  62.         if ((temp = getivar(val,PNAME)) == NIL || (ntype(temp) != STRING) ) { 
  63.             /* but nameless */
  64.             xlputstr(fptr,"#<class ???: #");
  65.         }
  66.         else {
  67.             sprintf(buf,"#<class %s: #",getstring(temp));
  68.             xlputstr(fptr,buf);
  69.         }
  70.     }
  71.     else { /* not a class */
  72.         if ((temp = getivar(temp,PNAME)) == NIL || (ntype(temp) != STRING) ) {
  73.             /* but nameless */
  74.             xlputstr(fptr,"#<a ??? object: #");
  75.         }
  76.         else {
  77.             sprintf(buf,"#<a %s: #",getstring(temp));
  78.             xlputstr(fptr,buf);
  79.         }
  80.     }
  81.     sprintf(buf,AFMT,val); 
  82.     xlputstr(fptr,buf);
  83.     xlputc(fptr,'>');
  84. }
  85.                 
  86. #endif
  87.  
  88. /* xsend - send a message to an object */
  89. LVAL xsend()
  90. {
  91.     LVAL obj;
  92.     obj = xlgaobject();
  93.     return (sendmsg(obj,getclass(obj),xlgasymbol()));
  94. }
  95.  
  96. /* xsendsuper - send a message to the superclass of an object */
  97. LVAL xsendsuper()
  98. {
  99.     LVAL env,p;
  100.     for (env = xlenv; env; env = cdr(env))
  101.         if (((p = car(env)) != 0) && objectp(car(p)))
  102.             return (sendmsg(car(p),
  103.                             getivar(cdr(p),SUPERCLASS),
  104.                             xlgasymbol()));
  105.     xlfail("not in a method");
  106.     return (NIL);    /* fake out compiler warning */
  107. }
  108.  
  109. /* xlclass - define a class */
  110. #ifdef ANSI
  111. static LVAL xlclass(char *name, int vcnt)
  112. #else
  113. LOCAL LVAL xlclass(name,vcnt)
  114.   char *name; int vcnt;
  115. #endif
  116. {
  117.     LVAL sym,cls;
  118.  
  119.     /* create the class */
  120.     sym = xlenter(name);
  121.     cls = newobject(class,CLASSSIZE);
  122.     setvalue(sym,cls);
  123.  
  124.     /* set the instance variable counts */
  125.     setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt));
  126.     setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt));
  127.  
  128. #ifdef OBJPRNT
  129.     /* set the class name    TAA Mod */
  130.     setivar(cls,PNAME,cvstring(name));
  131. #endif
  132.  
  133.     /* set the superclass to 'Object' */
  134.     setivar(cls,SUPERCLASS,object);
  135.  
  136.     /* return the new class */
  137.     return (cls);
  138. }
  139.  
  140. /* xladdivar - enter an instance variable */
  141. #ifdef ANSI
  142. static VOID xladdivar(LVAL cls, char *var)
  143. #else
  144. LOCAL VOID xladdivar(cls,var)
  145.   LVAL cls; char *var;
  146. #endif
  147. {
  148.     setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS)));
  149. }
  150.  
  151. /* xladdmsg - add a message to a class */
  152. #ifdef ANSI
  153. static VOID xladdmsg(LVAL cls, char *msg, int offset)
  154. #else
  155. LOCAL VOID xladdmsg(cls,msg,offset)
  156.   LVAL cls; char *msg; int offset;
  157. #endif
  158. {
  159.     extern FUNDEF funtab[];
  160.     LVAL mptr;
  161.  
  162.     /* enter the message selector */
  163.     mptr = entermsg(cls,xlenter(msg));
  164.  
  165.     /* store the method for this message */
  166.     rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset));
  167. }
  168.  
  169. /* xlobgetvalue - get the value of an instance variable */
  170. int xlobgetvalue(pair,sym,pval)
  171.   LVAL pair,sym,*pval;
  172. {
  173.     LVAL cls,names;
  174.     int ivtotal,n;
  175.  
  176.     /* find the instance or class variable */
  177.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  178.  
  179.         /* check the instance variables */
  180.         names = getivar(cls,IVARS);
  181.         ivtotal = getivcnt(cls,IVARTOTAL);
  182.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  183.             if (car(names) == sym) {
  184.                 *pval = getivar(car(pair),n);
  185.                 return (TRUE);
  186.             }
  187.             names = cdr(names);
  188.         }
  189.  
  190.         /* check the class variables */
  191.         names = getivar(cls,CVARS);
  192.         for (n = 0; consp(names); ++n) {
  193.             if (car(names) == sym) {
  194.                 *pval = getelement(getivar(cls,CVALS),n);
  195.                 return (TRUE);
  196.             }
  197.             names = cdr(names);
  198.         }
  199.     }
  200.  
  201.     /* variable not found */
  202.     return (FALSE);
  203. }
  204.  
  205. /* xlobsetvalue - set the value of an instance variable */
  206. int xlobsetvalue(pair,sym,val)
  207.   LVAL pair,sym,val;
  208. {
  209.     LVAL cls,names;
  210.     int ivtotal,n;
  211.  
  212.     /* find the instance or class variable */
  213.     for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) {
  214.  
  215.         /* check the instance variables */
  216.         names = getivar(cls,IVARS);
  217.         ivtotal = getivcnt(cls,IVARTOTAL);
  218.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  219.             if (car(names) == sym) {
  220.                 setivar(car(pair),n,val);
  221.                 return (TRUE);
  222.             }
  223.             names = cdr(names);
  224.         }
  225.  
  226.         /* check the class variables */
  227.         names = getivar(cls,CVARS);
  228.         for (n = 0; consp(names); ++n) {
  229.             if (car(names) == sym) {
  230.                 setelement(getivar(cls,CVALS),n,val);
  231.                 return (TRUE);
  232.             }
  233.             names = cdr(names);
  234.         }
  235.     }
  236.  
  237.     /* variable not found */
  238.     return (FALSE);
  239. }
  240.  
  241. /* obisnew - default 'isnew' method */
  242. LVAL obisnew()
  243. {
  244.     LVAL self;
  245.     self = xlgaobject();
  246.     xllastarg();
  247.     return (self);
  248. }
  249.  
  250. /* obclass - get the class of an object */
  251. LVAL obclass()
  252. {
  253.     LVAL self;
  254.     self = xlgaobject();
  255.     xllastarg();
  256.     return (getclass(self));
  257. }
  258.  
  259. /* obshow - show the instance variables of an object */
  260. LVAL obshow()
  261. {
  262.     LVAL self,fptr,cls,names;
  263.     int ivtotal,n;
  264.  
  265.     /* get self and the file pointer */
  266.     self = xlgaobject();
  267.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  268.     xllastarg();
  269.  
  270.     /* get the object's class */
  271.     cls = getclass(self);
  272.  
  273.     /* print the object and class */
  274.     xlputstr(fptr,"Object is ");
  275.     xlprint(fptr,self,TRUE);
  276.     xlputstr(fptr,", Class is ");
  277.     xlprint(fptr,cls,TRUE);
  278.     xlterpri(fptr);
  279.  
  280.     /* print the object's instance variables */
  281.     for (; cls; cls = getivar(cls,SUPERCLASS)) {
  282.         names = getivar(cls,IVARS);
  283.         ivtotal = getivcnt(cls,IVARTOTAL);
  284.         for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) {
  285.             xlputstr(fptr,"     ");
  286.             xlprint(fptr,car(names),TRUE);
  287.             xlputstr(fptr," = ");
  288.             xlprint(fptr,getivar(self,n),TRUE);
  289.             xlterpri(fptr);
  290.             names = cdr(names);
  291.         }
  292.     }
  293.  
  294.     /* return the object */
  295.     return (self);
  296. }
  297.  
  298. /* clnew - create a new object instance */
  299. LVAL clnew()
  300. {
  301.     LVAL self;
  302.     self = xlgaobject();
  303.     return (newobject(self,getivcnt(self,IVARTOTAL)));
  304. }
  305.  
  306. /* clisnew - initialize a new class */
  307. LVAL clisnew()
  308. {
  309.     LVAL self,ivars,cvars,super;
  310.     int n;
  311.  
  312.     /* get self, the ivars, cvars and superclass */
  313.     self = xlgaobject();
  314.     ivars = xlgalist();
  315.     cvars = (moreargs() ? xlgalist() : NIL);
  316.     super = (moreargs() ? xlgaobject() : object);
  317.     xllastarg();
  318.  
  319.     /* store the instance and class variable lists and the superclass */
  320.     setivar(self,IVARS,ivars);
  321.     setivar(self,CVARS,cvars);
  322.     setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL));
  323.     setivar(self,SUPERCLASS,super);
  324.  
  325.     /* compute the instance variable count */
  326.     n = listlength(ivars);
  327.     setivar(self,IVARCNT,cvfixnum((FIXTYPE)n));
  328.     n += getivcnt(super,IVARTOTAL);
  329.     setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n));
  330.  
  331.     /* return the new class object */
  332.     return (self);
  333. }
  334.  
  335. /* clanswer - define a method for answering a message */
  336. LVAL clanswer()
  337. {
  338.     LVAL self,msg,fargs,code,mptr;
  339.  
  340.     /* message symbol, formal argument list and code */
  341.     self = xlgaobject();
  342.     msg = xlgasymbol();
  343.     fargs = xlgalist();
  344.     code = xlgalist();
  345.     xllastarg();
  346.  
  347.     /* make a new message list entry */
  348.     mptr = entermsg(self,msg);
  349.  
  350.     /* setup the message node */
  351.     xlprot1(fargs);
  352.     fargs = cons(s_self,fargs); /* add 'self' as the first argument */
  353.         /* The following TAA MOD is by Neils Mayer, at HP */
  354.         /* it sets the lexical environment to be correct (non-global) */
  355. /*      rplacd(mptr,xlclose(msg,s_lambda,fargs,code,NIL,NIL)); */
  356.     rplacd(mptr,xlclose(msg,s_lambda,fargs,code,xlenv,xlfenv));
  357.     xlpop();
  358.  
  359.     /* return the object */
  360.     return (self);
  361. }
  362.  
  363. /* entermsg - add a message to a class */
  364. LOCAL LVAL entermsg(cls,msg)
  365.   LVAL cls,msg;
  366. {
  367.     LVAL lptr,mptr;
  368.  
  369.     /* lookup the message */
  370.     for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr))
  371.         if (car(mptr = car(lptr)) == msg)
  372.             return (mptr);
  373.  
  374.     /* allocate a new message entry if one wasn't found */
  375.     xlsave1(mptr);
  376.     mptr = consa(msg);
  377.     setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES)));
  378.     xlpop();
  379.  
  380.     /* return the symbol node */
  381.     return (mptr);
  382. }
  383.  
  384. /* sendmsg - send a message to an object */
  385. LOCAL LVAL sendmsg(obj,cls,sym)
  386.   LVAL obj,cls,sym;
  387. {
  388.     LVAL msg,msgcls,method,val,p;
  389.  
  390.     /* look for the message in the class or superclasses */
  391.     for (msgcls = cls; msgcls; ) {
  392.  
  393.         /* lookup the message in this class */
  394.         for (p = getivar(msgcls,MESSAGES); p; p = cdr(p))
  395.             if (((msg = car(p)) != 0) && car(msg) == sym)
  396.                 goto send_message;
  397.  
  398.         /* look in class's superclass */
  399.         msgcls = getivar(msgcls,SUPERCLASS);
  400.     }
  401.  
  402.     /* message not found */
  403.     xlerror("no method for this message",sym);
  404.  
  405. send_message:
  406.  
  407.     /* insert the value for 'self' (overwrites message selector) */
  408.     *--xlargv = obj;
  409.     ++xlargc;
  410.     
  411.     /* invoke the method */
  412.     if ((method = cdr(msg)) == NULL)
  413.         xlerror("bad method",method);
  414.     switch (ntype(method)) {
  415.     case SUBR:
  416.         val = (*getsubr(method))();
  417.         break;
  418.     case CLOSURE:
  419.         if (gettype(method) != s_lambda)
  420.             xlerror("bad method",method);
  421.         val = evmethod(obj,msgcls,method);
  422.         break;
  423.     default:
  424.         xlerror("bad method",method);
  425.     }
  426.  
  427.     /* after creating an object, send it the ":isnew" message */
  428.     if (car(msg) == k_new && val) {
  429.         xlprot1(val);
  430.         sendmsg(val,getclass(val),k_isnew);
  431.         xlpop();
  432.     }
  433.     
  434.     /* return the result value */
  435.     return (val);
  436. }
  437.  
  438. #ifdef MSC6
  439. /* no optimization which interferes with setjmp */
  440. #pragma optimize("elg",off)
  441. #endif
  442.  
  443. /* evmethod - evaluate a method */
  444. LOCAL LVAL evmethod(obj,msgcls,method)
  445.   LVAL obj,msgcls,method;
  446. {
  447.     LVAL oldenv,oldfenv,cptr,name,val;
  448.     CONTEXT cntxt;
  449.  
  450.     /* protect some pointers */
  451.     xlstkcheck(3);
  452.     xlsave(oldenv);
  453.     xlsave(oldfenv);
  454.     xlsave(cptr);
  455.  
  456.     /* create an 'object' stack entry and a new environment frame */
  457.     oldenv = xlenv;
  458.     oldfenv = xlfenv;
  459.     xlenv = cons(cons(obj,msgcls),getenvi(method));
  460.     xlenv = xlframe(xlenv);
  461.     xlfenv = getfenv(method);
  462.  
  463.     /* bind the formal parameters */
  464.     xlabind(method,xlargc,xlargv);
  465.  
  466.     /* setup the implicit block */
  467.     if ((name = getname(method)) != 0)
  468.         xlbegin(&cntxt,CF_RETURN,name);
  469.  
  470.     /* execute the block */
  471.     if (name && setjmp(cntxt.c_jmpbuf))
  472.         val = xlvalue;
  473.     else
  474.         for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr))
  475.             val = xleval(car(cptr));
  476.  
  477.     /* finish the block context */
  478.     if (name)
  479.         xlend(&cntxt);
  480.  
  481.     /* restore the environment */
  482.     xlenv = oldenv;
  483.     xlfenv = oldfenv;
  484.  
  485.     /* restore the stack */
  486.     xlpopn(3);
  487.  
  488.     /* return the result value */
  489.     return (val);
  490. }
  491.  
  492. #ifdef MSC6
  493. #pragma optimize("",on)
  494. #endif
  495.  
  496. /* getivcnt - get the number of instance variables for a class */
  497. #ifdef ANSI
  498. static int getivcnt(LVAL cls, int ivar)
  499. #else
  500. LOCAL int getivcnt(cls,ivar)
  501.   LVAL cls; int ivar;
  502. #endif
  503. {
  504.     LVAL cnt;
  505.     if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt))
  506.         xlfail("bad value for instance variable count");
  507.     return ((int)getfixnum(cnt));
  508. }
  509.  
  510. /* listlength - find the length of a list */
  511. #ifdef ANSI
  512. static int listlength(LVAL list)
  513. #else
  514. LOCAL int listlength(list)
  515.   LVAL list;
  516. #endif
  517. {
  518.     int len;
  519.     for (len = 0; consp(list); len++)
  520.         list = cdr(list);
  521.     return (len);
  522. }
  523.  
  524. /* obsymbols - initialize symbols */
  525. VOID obsymbols()
  526. {
  527.     /* enter the object related symbols */
  528.     s_self    = xlenter("SELF");
  529.     k_new    = xlenter(":NEW");
  530.     k_isnew = xlenter(":ISNEW");
  531. #ifdef OBJPRNT
  532.     k_prin1 = xlenter(":PRIN1");
  533. #endif
  534.  
  535.     /* get the Object and Class symbol values */
  536.     object = getvalue(xlenter("OBJECT"));
  537.     class  = getvalue(xlenter("CLASS"));
  538. }
  539.  
  540. /* xloinit - object function initialization routine */
  541. VOID xloinit()
  542. {
  543.     /* create the 'Class' object */
  544.     class = xlclass("CLASS",CLASSSIZE);
  545.     setelement(class,0,class);
  546.  
  547.     /* create the 'Object' object */
  548.     object = xlclass("OBJECT",0);
  549.  
  550.     /* finish initializing 'class' */
  551.     setivar(class,SUPERCLASS,object);
  552. #ifdef OBJPRNT
  553.     xladdivar(class,"PNAME");            /* ivar number 7  TAA Mod */
  554. #endif
  555.     xladdivar(class,"IVARTOTAL");        /* ivar number 6 */
  556.     xladdivar(class,"IVARCNT");            /* ivar number 5 */
  557.     xladdivar(class,"SUPERCLASS");        /* ivar number 4 */
  558.     xladdivar(class,"CVALS");            /* ivar number 3 */
  559.     xladdivar(class,"CVARS");            /* ivar number 2 */
  560.     xladdivar(class,"IVARS");            /* ivar number 1 */
  561.     xladdivar(class,"MESSAGES");        /* ivar number 0 */
  562.     xladdmsg(class,":NEW",FT_CLNEW);
  563.     xladdmsg(class,":ISNEW",FT_CLISNEW);
  564.     xladdmsg(class,":ANSWER",FT_CLANSWER);
  565.  
  566.     /* finish initializing 'object' */
  567.     setivar(object,SUPERCLASS,NIL);
  568.     xladdmsg(object,":ISNEW",FT_OBISNEW);
  569.     xladdmsg(object,":CLASS",FT_OBCLASS);
  570.     xladdmsg(object,":SHOW",FT_OBSHOW);
  571. #ifdef OBJPRNT
  572.     xladdmsg(object,":PRIN1",FT_OBPRIN1);
  573.  
  574.     /* other stuff needed in this module */
  575.     k_fix2 = cvfixnum((FIXTYPE)2);        /* so we don't have to recompute it */
  576. #endif
  577. }
  578.  
  579. #ifdef OBJPRNT
  580. /* default :PRIN1 method for objects */
  581. LVAL obprin1()
  582. {
  583.     LVAL self,fptr;
  584.  
  585.     /* get self and the file pointer */
  586.     self = xlgaobject();
  587.     fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout));
  588.     xllastarg();
  589.  
  590.     /* print it */
  591.     xputobj(fptr,self);
  592.  
  593.     /* return the object */
  594.     return (self);
  595. }
  596.  
  597. /* called by xlprint to tell an object to print itself by faking
  598.    a call like (send obj :prin1 fptr) */
  599. VOID putobj(fptr,obj)
  600.     LVAL fptr,obj;
  601. {
  602.     LVAL *oldargv;
  603.     int oldargc;
  604.  
  605.     /* check if there's room for the new call frame (5 slots needed) */
  606.     if (xlsp >= (xlargstktop-5)) xlargstkoverflow();
  607.  
  608.     /* create a new (dummy) call frame. dummy because (1) stack backtraces
  609.      * won't work anyway since if there's an error when PRINTing an object,
  610.      * that error will probably occur again during the backtrace, and
  611.      * (2) sendmsg() trashes the message selector slot.
  612.      */
  613.     *xlsp    = cvfixnum((FIXTYPE)(xlsp - xlfp));
  614.     xlfp    = xlsp++;    /* new frame pointer */
  615.     *xlsp++ = NIL;        /* dummy function */
  616.     *xlsp++ = k_fix2;    /* we have two arguments */
  617.     *xlsp++ = k_prin1; /* 1st arg: the message (trashed by sendmsg()) */
  618.     *xlsp++ = fptr;        /* 2nd arg: the file/stream */
  619.  
  620.     /* save old xlargc and xlargv. set up new ones */
  621.     oldargc = xlargc;
  622.     oldargv = xlargv;
  623.     xlargc    = 1;        /* one arg to be picked up */
  624.     xlargv    = xlfp + 4; /* points at 2nd arg: the file/stream */
  625.  
  626.     /* do it */
  627.     sendmsg(obj,getclass(obj),k_prin1);
  628.  
  629.     /* restore xlargc and xlargv */
  630.     xlargc    = oldargc;
  631.     xlargv    = oldargv;
  632.  
  633.     /* remove call frame */
  634.     xlsp    = xlfp;
  635.     xlfp   -= (int)getfixnum(*xlfp);
  636. }
  637. #endif
  638.  
  639.